perm filename QLOG[1,JRA] blob
sn#527002 filedate 1980-07-31 generic text, type T, neo UTF8
(FILECREATED "20-Apr-80 17:30:40" <PROLOG>QLOG..8 10831
changes to: +GOAL+ +GOAL1+ +CONTINUE+ +PEVAL+
previous date: "18-Apr-80 15:05:06" <PROLOG>QLOG..7)
(PRETTYCOMPRINT QLOGCOMS)
(RPAQQ QLOGCOMS ((* COPYRIGHT: Henry Jan Komorowski, Informatics
Laboratory, Linkoeping University, Sweden)
(BLOCKS * QLOGBLOCKS)
(VARS (ALLFLG)
(CLISPFLG T)
(NOCCURFLG T)
(*ANDSTACK*)
(*FRAMESTACK*)
(*ORSTACK*)
(DYNORSTACK#)
(CLOSURE (CONS))
(QFN#)
(TUPLE#))
(FNS * QLOGFNS)
(PROP DESCRIPTION QLOG)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
COMPILERVARS (ADDVARS (NLAMA LISP)
(NLAML)
(LAMA)))))
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* COPYRIGHT: Henry Jan Komorowski, Informatics Laboratory,
Linkoeping University, Sweden) ]
(RPAQQ QLOGBLOCKS ((SERVUSBLOCK +ASK+ +BLOWUP+ +CLEAR+ +CONTINUE+ +CSI+
+CSI1+ +CSI2+ +GOAL+ +GOAL1+ +INSERT+
+INSTANT+ +LBFORM+ +LBLIS+ +NOCCUR+
+NOCCUR1+ +PEVAL+ +PRINSUBS+ +REMEMBER+
+UNIFY+ CUT CUTALL LISP GV.BND GV.ENV
GV.SLT GV.LBND GV.LSLT LBFORM LBLIS
(ENTRIES CUT LISP +GOAL+)
(SPECVARS ANDLST# DYNORSTACK# CLOSURE
LOCALINS# NOCCURFLG ORLST#
PROC# QFN# REMOTEINS# TUPLE#
*ANDSTACK* *FRAMESTACK*
*ORSTACK*)
(BLKAPPLYFNS CUT LISP +PRINSUBS+)
(BLKLIBRARY GETPROP))))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: SERVUSBLOCK +ASK+ +BLOWUP+ +CLEAR+ +CONTINUE+ +CSI+ +CSI1+
+CSI2+ +GOAL+ +GOAL1+ +INSERT+ +INSTANT+ +LBFORM+ +LBLIS+
+NOCCUR+ +NOCCUR1+ +PEVAL+ +PRINSUBS+ +REMEMBER+ +UNIFY+ CUT
CUTALL LISP GV.BND GV.ENV GV.SLT GV.LBND GV.LSLT LBFORM LBLIS
(ENTRIES CUT LISP +GOAL+)
(SPECVARS ANDLST# DYNORSTACK# CLOSURE LOCALINS# NOCCURFLG
ORLST# PROC# QFN# REMOTEINS# TUPLE# *ANDSTACK*
*FRAMESTACK* *ORSTACK*)
(BLKAPPLYFNS CUT LISP +PRINSUBS+)
(BLKLIBRARY GETPROP))
]
(RPAQ ALLFLG NIL)
(RPAQ CLISPFLG T)
(RPAQ NOCCURFLG T)
(RPAQ *ANDSTACK* NIL)
(RPAQ *FRAMESTACK* NIL)
(RPAQ *ORSTACK* NIL)
(RPAQ DYNORSTACK# NIL)
(RPAQ CLOSURE (CONS))
(RPAQ QFN# NIL)
(RPAQ TUPLE# NIL)
(RPAQQ QLOGFNS (+GOAL+ +UNIFY+ +CSI+ +CSI1+ +CSI2+ +NOCCUR+ +NOCCUR1+
+GOAL1+ +CONTINUE+ +PEVAL+ +CLEAR+ +INSERT+
+INSTANT+ +REMEMBER+ CUT CUTALL LISP))
(DEFINEQ
(+GOAL+
(LAMBDA (PATTERN NAM) (* edited:
"20-Apr-80 17:18")
(PROG ((PREVCLOSURE CLOSURE)
(CLOSURE (NCONC (CONS)
CLOSURE))
(ORLST# (CONS NAM (GETPROP NAM (QUOTE PEXPR))))
ANDLST# LOCALINS# REMOTEINS# SAVED←CLOSURE
SAVED←PREVCLOSURE)
(* Obs! The CLOSURE variable appearing in the PROG
declaration refers to the external binding of
CLOSURE.)
TRYMATCH
(COND
((EQ (+UNIFY+ PATTERN CLOSURE PREVCLOSURE)
(QUOTE FAILMATCH))
(RETURN (QUOTE FAILURE))))
(+GOAL1+ (CONS CLOSURE *FRAMESTACK*)
(CONS ANDLST# *ANDSTACK*)
(CONS ORLST# *ORSTACK*))
(GO TRYMATCH))))
(+UNIFY+
(LAMBDA (PATTERN2 CLOSURE PREVCLOSURE) (* edited:
"12-Apr-80 17:30")
(PROG (PATTERN1 TEMPAND)
TRYNEXT
(+CLEAR+)
(OR (CDR ORLST#)
(RETURN (QUOTE FAILMATCH))) (* These four setqs
should be smarter
arranged.)
(SETQ TEMPAND (CADR ORLST#))
(SETQ PATTERN1 (CDAR TEMPAND))
(SETQ ANDLST# (CDR TEMPAND))
(FRPLACD ORLST# (CDDR ORLST#))
(OR (+CSI+ PATTERN1 PATTERN2 CLOSURE PREVCLOSURE)
(GO TRYNEXT)))))
(+CSI+
(LAMBDA (PAT1 PAT2 CLOSR PREVCLOSR) (* edited:
"12-Apr-80 17:34")
(for EXPR1 on PAT1 as EXPR2 on PAT2 always (+CSI1+ (CAR EXPR1)
(CAR EXPR2)
CLOSR PREVCLOSR)
finally (RETURN (AND $$VAL (NLISTP EXPR1)
(NLISTP EXPR2))))))
(+CSI1+
(LAMBDA (EXP1 EXP2 CLSR PREVCLSR) (* edited:
"16-Apr-80 13:30")
(PROG (SLOT1 SLOT2)
(AND (EQ (CAR EXP1)
(QUOTE VAR))
(PROG2 (SETQ EXP1 (GV.BND (SETQ SLOT1 (GV.SLT EXP1 CLSR))
))
(SETQ CLSR (GV.ENV SLOT1))))
(AND (EQ (CAR EXP2)
(QUOTE VAR))
(PROG2 (SETQ EXP2 (GV.BND (SETQ SLOT2 (GV.SLT EXP2
PREVCLSR))))
(SETQ PREVCLSR (GV.ENV SLOT2))))
(COND
((EQ (CAR EXP1)
(QUOTE VAR))
(RETURN (AND (OR NOCCURFLG (+NOCCUR+ EXP1 EXP2 CLSR
PREVCLSR))
(+INSTANT+ SLOT1 SLOT2 EXP2 PREVCLSR))))
((EQ (CAR EXP2)
(QUOTE VAR))
(RETURN (AND (OR NOCCURFLG (+NOCCUR+ EXP2 EXP1 PREVCLSR
CLSR))
(+INSTANT+ SLOT2 SLOT1 EXP1 CLSR))))
((ATOM EXP1)
(RETURN (EQUAL EXP1 EXP2)))
((ATOM EXP2)
(RETURN))
((EQ (CAR EXP1)
(CAR EXP2))
(RETURN (+CSI2+ (CDR EXP1)
(CDR EXP2)
CLSR PREVCLSR (EQ (CAR EXP1)
(QUOTE @)))))))))
(+CSI2+
(LAMBDA (EXP1 EXP2 FM OFM LSTFLG) (* edited:
"16-Apr-80 16:35")
(PROG ((X1 EXP1)
(X2 EXP2))
LOOP(COND
((OR (NLISTP X1)
(NLISTP X2))
(GO LSTLP)))
(COND
((AND (EQ (CAAR X1)
(QUOTE FRAG))
(EQ (CAAR X2)
(QUOTE FRAG)))
(RETURN (+CSI1+ (CADAR X1)
(CADAR X2)
FM OFM)))
((EQ (CAAR X1)
(QUOTE FRAG))
(RETURN (+CSI1+ (CADAR X1)
(CONS (QUOTE @)
X2)
FM OFM)))
((EQ (CAAR X2)
(QUOTE FRAG))
(RETURN (+CSI1+ (CONS (QUOTE @)
X1)
(CADAR X2)
FM OFM)))
((NULL (+CSI1+ (CAR X1)
(CAR X2)
FM OFM))
(RETURN)))
ITERATE
(SETQ X1 (CDR X1))
(SETQ X2 (CDR X2))
(GO LOOP)
LSTLP
(AND LSTFLG (RETURN (COND
((AND (NULL X1)
(NULL X2)))
((AND (EQ (CAAR X1)
(QUOTE FRAG))
(EQ (CAAR X2)
(QUOTE FRAG)))
(+CSI1+ (CADAR X1)
(CADAR X2)
FM OFM))
((EQ (CAAR X1)
(QUOTE FRAG))
(+CSI1+ (CADAR X1)
(QUOTE (@))
FM OFM))
((EQ (CAAR X2)
(QUOTE FRAG))
(+CSI1+ (QUOTE (@))
(CADAR X2)
FM OFM)))))
(RETURN (NOT (OR X1 X2))))))
(+NOCCUR+
(LAMBDA (EX1 EX2 ENV2) (* edited:
"10-Feb-80 23:55")
(COND
((LITATOM EX2))
(T (for TERMS in (CDR EX2) always (+NOCCUR1+ EX1 TERMS ENV2))))))
(+NOCCUR1+
(LAMBDA (X1 X2 NV2) (* edited:
"11-Feb-80 00:14")
(AND (LITATOM X2)
(SETQ X2 (GV.BND (GV.SLT X2 NV2))))
(COND
((LITATOM X2)
(NEQ X1 X2))
(T (for VAR in (CDR X2) always (+NOCCUR1+ X1 VAR NV2))))))
(+GOAL1+
(LAMBDA (*FRAMESTACK* *ANDSTACK* *ORSTACK*) (* edited:
"20-Apr-80 17:07")
(PROG ((DYNORSTACK# (CONS ORLST# DYNORSTACK#))
PROC#)
(SETQ SAVED←CLOSURE
CLOSURE)
(SETQ SAVED←PREVCLOSURE
PREVCLOSURE)
EVL (AND (NEQ (+CONTINUE+)
(QUOTE MORE))
(NEQ (+PEVAL+ PROC#)
(QUOTE FAILURE))
(GO EVL))
(SETQ CLOSURE SAVED←CLOSURE)
(SETQ PREVCLOSURE SAVED←PREVCLOSURE))))
(+CONTINUE+
(LAMBDA NIL (* edited:
"20-Apr-80 17:19")
(PROG NIL
L (COND
((CAR *ANDSTACK*)
(SETQ CLOSURE (CAR *FRAMESTACK*))
(SETQ PREVCLOSURE (CDR CLOSURE))
(SETQ PROC# (CAAR *ANDSTACK*))
(SETQ *ANDSTACK* (CONS (CDAR *ANDSTACK*)
(CDR *ANDSTACK*))))
((SETQ *ANDSTACK* (CDR *ANDSTACK*))
(SETQ *ORSTACK* (CDR *ORSTACK*))
(SETQ *FRAMESTACK* (CDR *FRAMESTACK*))
(GO L))
(T (BLKAPPLY (OR QFN# (QUOTE +PRINSUBS+))
TUPLE#)
(RETURN (QUOTE MORE)))))))
(+PEVAL+
(LAMBDA (PRO) (* edited:
"20-Apr-80 16:33")
(COND
((EQ (CAR PRO)
(QUOTE VAR))
(* It is uncertain what should happen if the atomic
PRO is unbound in the sense of QLOG, i.e. before the
call to GV.SLT the PRO's slot didn't exist, either
PRO was unbound.)
(EVAL (GV.BND (GV.SLT PRO CLOSURE))))
((EVAL PRO)))))
(+CLEAR+
(LAMBDA NIL (* edited:
"13-Apr-80 04:23")
(for R in REMOTEINS# do (FRPLACA (CDAR R)
(CADR R))
(FRPLACD (CDAR R)
(CDDR R)))
(for L in LOCALINS# do (FRPLACD L (CONS (LIST (QUOTE VAR)
(CAR L))
CLOSURE)))
(SETQ REMOTEINS#)
(SETQ LOCALINS#)))
(+INSERT+
(LAMBDA (AM FM) (* edited:
"12-Apr-80 21:46")
(FRPLACA FM (CONS (CONS (CADR AM)
(CONS AM FM))
(CAR FM)))
(CAAR FM)))
(+INSTANT+
(LAMBDA (SL1 SL2 EXP CLOS) (* edited:
"16-Apr-80 14:01")
(COND
((OR (NULL SL2)
(NEQ (GV.NAM SL1)
(CADR (GV.BND SL1)))
(NEQ (GV.ENV SL2)
CLOS))
(* THE ABOVE (CADR ...) IS UNRELIABLE WHEN THE
BINDING IS A CONSTANT I.E. AN ATOM, OR A STRING, OR
A NUMBER)
(+REMEMBER+ SL1)
(FRPLACA (CDR SL1)
EXP))
(T (+REMEMBER+ SL1 T)
(+REMEMBER+ SL2)
(FRPLACD SL1 (CDR SL2))))
(FRPLACD (CDR SL1)
CLOS)
T))
(+REMEMBER+
(LAMBDA (SLOT LCLFLG) (* edited:
"13-Apr-80 00:24")
(COND
(LCLFLG (SETQ LOCALINS# (CONS SLOT LOCALINS#)))
((SETQ REMOTEINS# (CONS (CONS SLOT (CONS (GV.BND SLOT)
(GV.ENV SLOT)))
REMOTEINS#))))))
(CUT
(LAMBDA NIL (* edited:
"10-Feb-80 19:41")
(for X in DYNORSTACK# until (EQ X (CAR *ORSTACK*))
do (FRPLACD X) finally (FRPLACD X))
(+GOAL1+ *FRAMESTACK* *ANDSTACK* *ORSTACK*)
(QUOTE FAILURE)))
(CUTALL
(LAMBDA NIL (* edited:
" 8-Feb-80 20:59")
(for X in DYNORSTACK# until (EQ X (CAR *ORSTACK*))
do (FRPLACD X) finally (FRPLACD X))))
(LISP
(NLAMBDA FORMS (* edited:
"18-Apr-80 15:03")
(AND (for FS in FORMS never (EQ (APPLY (CAR FS)
(LBLIS (CDR FS)
CLOSURE))
(QUOTE FAILURE)))
(+GOAL1+ *FRAMESTACK* *ANDSTACK* *ORSTACK*))
(QUOTE FAILURE)))
)
(PUTPROPS QLOG DESCRIPTION (This is the kernel of the QLOG system.
Internal notation is assumed. Macros
for system functions should be put.))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA LISP)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (2404 10516 (+GOAL+ 2416 . 3127) (+UNIFY+ 3131 . 3677) (
+CSI+ 3681 . 3977) (+CSI1+ 3981 . 5043) (+CSI2+ 5047 . 6393) (+NOCCUR+
6397 . 6600) (+NOCCUR1+ 6604 . 6876) (+GOAL1+ 6880 . 7358) (+CONTINUE+
7362 . 7960) (+PEVAL+ 7964 . 8381) (+CLEAR+ 8385 . 8743) (+INSERT+ 8747
. 8941) (+INSTANT+ 8945 . 9469) (+REMEMBER+ 9473 . 9755) (CUT 9759 .
10022) (CUTALL 10026 . 10222) (LISP 10226 . 10513)))))
STOP
ββββ